home *** CD-ROM | disk | FTP | other *** search
/ QRZ! Ham Radio 8 / QRZ Ham Radio Callsign Database - Volume 8.iso / pc / files / ant_nec / nec81tar.z / nec81tar / factrs.f < prev    next >
Text File  |  1991-05-13  |  14KB  |  589 lines
  1. C $TITLE: 'FACTRS'
  2. C $NOFLOATCALLS
  3.       SUBROUTINE FACTRS(A,SCRATC,NP,NROW,IP,IX,IU1,IU2,IU3,IU4,
  4.      1 LD2,IRESRV)
  5. C
  6. C     FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM
  7. C     MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR
  8. C     MATRICIES.  IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE
  9. C     COMPLETE MATRIX.
  10. C
  11.       INTEGER*4 I2,NP,NROW,IDM1,KA,KK,NOP
  12.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  13. CLARGE: A
  14.       COMPLEX A
  15.       COMPLEX*16 SCRATC
  16.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  17.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  18.       DIMENSION A(1),SCRATC(LD2),IP(LD2),IX(LD2)
  19. C**
  20. C     D     WRITE(*,*) '  FACTRS: ICASE=',ICASE,' ICASX=',ICASX
  21.       IRESRV=IRESRV
  22. C**
  23.       IDM1=1
  24.       NOP=NROW/NP
  25.       IF (ICASE.GT.2) GO TO 2
  26. C**
  27.       DO 1 KK=1,NOP
  28.       KA=(KK-1)*NP+1
  29. C**
  30. C     D     WRITE(*,*) '  FACTRS: CALL FACTR, KA=',KA,' NP=',NP,' NROW=',NROW
  31. C**
  32.       CALL FACTR(A(KA),SCRATC,NP,NROW,IP(KA),LD2)
  33. C**
  34. C     D     WRITE(*,*) '  FACTRS: RTRN FACTR'
  35. C**
  36. 1     CONTINUE
  37. C**
  38. C     D     WRITE(*,*) '  FACTRS: RETURN AFTER 1'
  39. C**
  40.       RETURN
  41. 2     IF (ICASE.GT.3) GO TO 3
  42. C
  43. C     FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY
  44. C     EXISTS.
  45. C**
  46. C     D     WRITE(*,*) '  FACTRS: CALL FACIO'
  47. C**
  48.       CALL FACIO (A,SCRATC,NROW,NOP,IX,IU1,IU2,IU3,IU4,LD2)
  49. C**
  50. C     D     WRITE(*,*) '  FACTRS: RTRN FACIO'
  51. C     D     WRITE(*,*) '  FACTRS: CALL LUNSCR'
  52. C**
  53.       CALL LUNSCR (A,NROW,NOP,IP,IX,IU2,IU3,IU4)
  54. C**
  55. C     D     WRITE(*,*) '  FACTRS: RTRN LUNSCR'
  56. C     D     WRITE(*,*) '  FACTRS: RETURN BEFORE 3'
  57. C**
  58.       RETURN
  59. C
  60. C     REWRITE THE MATRICES BY COLUMNS ON TAPE 13
  61. C
  62. 3     I2=2*NPBLK*NROW
  63.       REWIND IU2
  64.       DO 5 K=1,NOP
  65.       REWIND IU1
  66.       ICOLS=NPBLK
  67.       IR2=K*NP
  68.       IR1=IR2-NP+1
  69.       DO 5 L=1,NBLOKS
  70.       IF (NBLOKS.EQ.1.AND.K.GT.1) GO TO 4
  71. C**
  72. C     D     WRITE(*,*) '  FACTRS: CALL BLCKIN'
  73. C**
  74.       CALL BLCKIN (A,IDM1,I2,1,602,IU1)
  75. C**
  76. C     D     WRITE(*,*) '  FACTRS: RTRN BLCKIN'
  77. C**
  78.       IF (L.EQ.NBLOKS) ICOLS=NLAST
  79. 4     IRR1=IR1
  80.       IRR2=IR2
  81.       DO 5 ICOLDX=1,ICOLS
  82.       WRITE (IU2) (A(I),I=IRR1,IRR2)
  83.       IRR1=IRR1+NROW
  84.       IRR2=IRR2+NROW
  85. 5     CONTINUE
  86.       REWIND IU1
  87.       REWIND IU2
  88.       IF (ICASE.EQ.5) GO TO 8
  89.       REWIND IU3
  90.       IRR1=NP*NP
  91.       DO 7 KK=1,NOP
  92.       IR1=1-NP
  93.       IR2=0
  94.       DO 6 I=1,NP
  95.       IR1=IR1+NP
  96.       IR2=IR2+NP
  97. 6     READ (IU2) (A(J),J=IR1,IR2)
  98.       KA=(KK-1)*NP+1
  99. C**
  100. C     D     WRITE(*,*) '  FACTRS: CALL FACTR AFTER 6, KA=',KA,' NP=',NP
  101. C**
  102.       CALL FACTR(A,SCRATC,NP,NP,IP(KA),LD2)
  103. C**
  104. C     D     WRITE(*,*) '  FACTRS: RTRN FACTR AFTER 6'
  105. C**
  106.       WRITE (IU3) (A(I),I=1,IRR1)
  107. 7     CONTINUE
  108.       REWIND IU2
  109.       REWIND IU3
  110.       RETURN
  111. 8     I2=2*NPSYM*NP
  112.       DO 10 KK=1,NOP
  113.       J2=NPSYM
  114.       DO 10 L=1,NBLSYM
  115.       IF (L.EQ.NBLSYM) J2=NLSYM
  116.       IR1=1-NP
  117.       IR2=0
  118.       DO 9 J=1,J2
  119.       IR1=IR1+NP
  120.       IR2=IR2+NP
  121. 9     READ (IU2) (A(I),I=IR1,IR2)
  122. 10     CONTINUE
  123. C**
  124. C     D     WRITE(*,*) '  FACTRS: CALL BLCKOT'
  125. C**
  126.       CALL BLCKOT (A,IDM1,I2,1,193,IU1)
  127. C     D     WRITE(*,*) '  FACTRS: RTRN BLCKOT'
  128. C**
  129.       REWIND IU1
  130. C**
  131. C     D     WRITE(*,*) '  FACTRS: CALL FACIO'
  132. C**
  133.       CALL FACIO (A,SCRATC,NP,NOP,IX,IU1,IU2,IU3,IU4,LD2)
  134. C**
  135. C     D     WRITE(*,*) '  FACTRS: RTRN FACIO'
  136. C     D     WRITE(*,*) '  FACTRS: CALL LUNSCR'
  137. C**
  138.       CALL LUNSCR (A,NP,NOP,IP,IX,IU2,IU3,IU4)
  139. C**
  140. C     D     WRITE(*,*) '  FACTRS: RTRN LUNSCR'
  141. C     D     WRITE(*,*) '  FACTRS: RETURN AT END'
  142. C**
  143.       RETURN
  144.       END
  145. C
  146. C
  147. C
  148.       SUBROUTINE REBLK (B,BX,NB,NBX,N2C)
  149. C     REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14
  150. C     TO BLOCKS OF COLUMNS ON TAPE16
  151.       INTEGER*4 NB,NBX,N2C
  152.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  153. CLARGE: B,BX
  154.       COMPLEX B,BX
  155.       DIMENSION B(NB,1),BX(NBX,1)
  156.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  157.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  158. C**
  159. C     E     WRITE(*,*) '   REBLK: START NBBL=',NBBL
  160. C**
  161.       REWIND 16
  162.       NIB=0
  163.       NPB=NPBL
  164.       DO 3 IB=1,NBBL
  165.       IF (IB.EQ.NBBL) NPB=NLBL
  166.       REWIND 14
  167.       NIX=0
  168.       NPX=NPBX
  169.       DO 2 IBX=1,NBBX
  170.       IF (IBX.EQ.NBBX) NPX=NLBX
  171.       READ (14) ((BX(I,J),I=1,NPX),J=1,N2C)
  172.       DO 1 I=1,NPX
  173.       IX=I+NIX
  174.       DO 1 J=1,NPB
  175. 1     B(IX,J)=BX(I,J+NIB)
  176. 2     NIX=NIX+NPBX
  177.       WRITE (16) ((B(I,J),I=1,NB),J=1,NPB)
  178. 3     NIB=NIB+NPBL
  179.       REWIND 14
  180.       REWIND 16
  181. C**
  182. C     E     WRITE(*,*) '   REBLK: RETURN'
  183. C**
  184.       RETURN
  185.       END
  186. C
  187. C
  188. C
  189.       SUBROUTINE FACIO (A,D,NROW,NOP,IP,IU1,IU2,IU3,IU4,LD2)
  190. C
  191. C     FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION
  192. C
  193.       INTEGER*4 I1,I2,I3,I4,IT,NROW
  194. CLARGE A
  195.       COMPLEX A
  196.       COMPLEX*16 D
  197.       DIMENSION A(NROW,1),IP(NROW),D(LD2)
  198.       INTEGER*4 NOP,KK
  199.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  200.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  201.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  202. C**
  203. C     D     WRITE(*,*) '   FACIO: START'
  204. C**
  205.       IT=2*NPSYM*NROW
  206.       NBM=NBLSYM-1
  207.       I1=1
  208.       I2=IT
  209.       I3=I2+1
  210.       I4=2*IT
  211.       TIME=0.
  212.       REWIND IU1
  213.       REWIND IU2
  214.       DO 3 KK=1,NOP
  215.       KA=(KK-1)*NROW+1
  216.       IFILE3=IU1
  217.       IFILE4=IU3
  218.       DO 2 IXBLK1=1,NBM
  219.       REWIND IU3
  220.       REWIND IU4
  221.       CALL BLCKIN (A,I1,I2,1,17,IFILE3)
  222.       IXBP=IXBLK1+1
  223.       DO 1 IXBLK2=IXBP,NBLSYM
  224.       CALL BLCKIN (A,I3,I4,1,18,IFILE3)
  225.       CALL SECOND (T1)
  226.       CALL LFACTR (A,D,NROW,IXBLK1,IXBLK2,IP(KA),LD2)
  227.       CALL SECOND (T2)
  228.       TIME=TIME+T2-T1
  229.       IF (IXBLK2.EQ.IXBP) CALL BLCKOT (A,I1,I2,1,19,IU2)
  230.       IF (IXBLK1.EQ.NBM.AND.IXBLK2.EQ.NBLSYM) IFILE4=IU2
  231.       CALL BLCKOT (A,I3,I4,1,20,IFILE4)
  232. 1     CONTINUE
  233.       IFILE3=IU3
  234.       IFILE4=IU4
  235.       IF ((IXBLK1/2)*2.NE.IXBLK1) GO TO 2
  236.       IFILE3=IU4
  237.       IFILE4=IU3
  238. 2     CONTINUE
  239. 3     CONTINUE
  240.       REWIND IU1
  241.       REWIND IU2
  242.       REWIND IU3
  243.       REWIND IU4
  244.       WRITE(*,4)  TIME
  245.       RETURN
  246. C
  247. 4     FORMAT (' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5)
  248.       END
  249. C
  250. C
  251. C
  252.       SUBROUTINE LUNSCR (A,NROW,NOP,IX,IP,IU2,IU3,IU4)
  253. C
  254. C     S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX
  255. C
  256.       INTEGER*4 I1,I2,NROW
  257. CLARGE A
  258.       COMPLEX A
  259.       COMPLEX*16 TEMP
  260.       DIMENSION A(NROW,1),IP(NROW),IX(NROW)
  261.       INTEGER*4 NOP,KA,KK
  262.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  263.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  264.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  265. C**
  266. C     D     WRITE(*,*) '   LUNSCR: START'
  267. C**
  268.       I1=1
  269.       I2=2*NPSYM*NROW
  270.       NM1=NROW-1
  271.       REWIND IU2
  272.       REWIND IU3
  273.       REWIND IU4
  274.       DO 9 KK=1,NOP
  275.       KA=(KK-1)*NROW
  276.       DO 4 IXBLK1=1,NBLSYM
  277.       CALL BLCKIN (A,I1,I2,1,121,IU2)
  278.       K1=(IXBLK1-1)*NPSYM+2
  279.       IF (NM1.LT.K1) GO TO 3
  280.       J2=0
  281.       DO 2 K=K1,NM1
  282.       IF (J2.LT.NPSYM) J2=J2+1
  283.       IPK=IP(K+KA)
  284.       DO 1 J=1,J2
  285.       TEMP=A(K,J)
  286.       A(K,J)=A(IPK,J)
  287.       A(IPK,J)=TEMP
  288. 1     CONTINUE
  289. 2     CONTINUE
  290. 3     CONTINUE
  291.       CALL BLCKOT (A,I1,I2,1,122,IU3)
  292. 4     CONTINUE
  293.       DO 5 IXBLK1=1,NBLSYM
  294.       BACKSPACE IU3
  295.       IF (IXBLK1.NE.1) BACKSPACE IU3
  296.       CALL BLCKIN (A,I1,I2,1,123,IU3)
  297.       CALL BLCKOT (A,I1,I2,1,124,IU4)
  298. 5     CONTINUE
  299.       DO 6 I=1,NROW
  300.       IX(I+KA)=I
  301. 6     CONTINUE
  302.       DO 7 I=1,NROW
  303.       IPI=IP(I+KA)
  304.       IXT=IX(I+KA)
  305.       IX(I+KA)=IX(IPI+KA)
  306.       IX(IPI+KA)=IXT
  307. 7     CONTINUE
  308.       IF (NOP.EQ.1) GO TO 9
  309.       NB1=NBLSYM-1
  310. C     SKIP NB1 LOGICAL RECORDS FORWARD
  311.       DO 8 IXBLK1=1,NB1
  312.       CALL BLCKIN (A,I1,I2,1,125,IU3)
  313. 8     CONTINUE
  314. 9     CONTINUE
  315.       REWIND IU2
  316.       REWIND IU3
  317.       REWIND IU4
  318.       RETURN
  319.       END
  320. C
  321. C
  322. C
  323.       SUBROUTINE LFACTR (A,D,NROW,IX1,IX2,IP,LD2)
  324. C
  325. C     LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
  326. C     THE TRANSPOSED MATRIX IN CORE STORAGE.  THE GAUSS-DOOLITTLE
  327. C     ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST
  328. C     COURSE IN NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN
  329. C     RALSTONS TEXT.
  330. C
  331. CLARGE A
  332.       COMPLEX A
  333.       COMPLEX*16 D,AJR
  334.       REAL*8 DMAX,ELMAG
  335.       INTEGER*4 NROW
  336.       INTEGER R,R1,R2,PJ,PR
  337.       LOGICAL L1,L2,L3
  338.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  339.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  340.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  341.       DIMENSION A(NROW,1),IP(NROW),D(LD2)
  342. C**
  343. C     D     WRITE(*,*) '   LFACTR: START'
  344. C**
  345.       IFLG=0
  346. C
  347. C     INITIALIZE R1,R2,J1,J2
  348. C
  349.       L1=IX1.EQ.1.AND.IX2.EQ.2
  350.       L2=(IX2-1).EQ.IX1
  351.       L3=IX2.EQ.NBLSYM
  352.       IF (L1) GO TO 1
  353.       GO TO 2
  354. 1     R1=1
  355.       R2=2*NPSYM
  356.       J1=1
  357.       J2=-1
  358.       GO TO 5
  359. 2     R1=NPSYM+1
  360.       R2=2*NPSYM
  361.       J1=(IX1-1)*NPSYM+1
  362.       IF (L2) GO TO 3
  363.       GO TO 4
  364. 3     J2=J1+NPSYM-2
  365.       GO TO 5
  366. 4     J2=J1+NPSYM-1
  367. 5     IF (L3) R2=NPSYM+NLSYM
  368.       DO 16 R=R1,R2
  369. C
  370. C     STEP 1
  371. C
  372.       DO 6 K=J1,NROW
  373.       D(K)=A(K,R)
  374. 6     CONTINUE
  375. C
  376. C     STEPS 2 AND 3
  377. C
  378.       IF (L1.OR.L2) J2=J2+1
  379.       IF (J1.GT.J2) GO TO 9
  380.       IXJ=0
  381.       DO 8 J=J1,J2
  382.       IXJ=IXJ+1
  383.       PJ=IP(J)
  384.       AJR=D(PJ)
  385.       A(J,R)=AJR
  386.       D(PJ)=D(J)
  387.       JP1=J+1
  388.       DO 7 I=JP1,NROW
  389.       D(I)=D(I)-A(I,IXJ)*AJR
  390. 7     CONTINUE
  391. 8     CONTINUE
  392. 9     CONTINUE
  393. C
  394. C     STEP 4
  395. C
  396.       J2P1=J2+1
  397.       IF (L1.OR.L2) GO TO 11
  398.       IF (NROW.LT.J2P1) GO TO 16
  399.       DO 10 I=J2P1,NROW
  400.       A(I,R)=D(I)
  401. 10    CONTINUE
  402.       GO TO 16
  403. 11    DMAX=DREAL(D(J2P1)*DCONJG(D(J2P1)))
  404.       IP(J2P1)=J2P1
  405.       J2P2=J2+2
  406.       IF (J2P2.GT.NROW) GO TO 13
  407.       DO 12 I=J2P2,NROW
  408.       ELMAG=DREAL(D(I)*DCONJG(D(I)))
  409.       IF (ELMAG.LT.DMAX) GO TO 12
  410.       DMAX=ELMAG
  411.       IP(J2P1)=I
  412. 12    CONTINUE
  413. 13    CONTINUE
  414.       IF (DMAX.LT.1.E-10) IFLG=1
  415.       PR=IP(J2P1)
  416.       A(J2P1,R)=D(PR)
  417.       D(PR)=D(J2P1)
  418. C
  419. C     STEP 5
  420. C
  421.       IF (J2P2.GT.NROW) GO TO 15
  422.       AJR=1.D0/A(J2P1,R)
  423.       DO 14 I=J2P2,NROW
  424.       A(I,R)=D(I)*AJR
  425. 14    CONTINUE
  426. 15    CONTINUE
  427.       IF (IFLG.EQ.0) GO TO 16
  428.       WRITE(*,17)  J2,DMAX
  429.       IFLG=0
  430. 16    CONTINUE
  431. C**
  432. C     D     WRITE(*,*) '   LFACTR: RETURN'
  433. C**
  434.       RETURN
  435. C
  436. 17    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,D16.8)
  437.       END
  438. C
  439. C
  440. C
  441.       SUBROUTINE FACGF(A,B,C,D,BX,SCRATC,IP,IX,NP,N1,
  442.      1 MP,M1,N1C,N2C,LD2,IRESRV)
  443. C     FACGF COMPUTES AND FACTORS D-C(INV(A)B).
  444.       INTEGER*4 NP,N1,MP,M1,N1C,N2C,IDM2,N1CP
  445.       INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  446. CLARGE: A,B,C,D,BX
  447.       COMPLEX A,B,C,D,BX
  448.       COMPLEX*16 SUM,SCRATC
  449.       COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
  450.      1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
  451.       DIMENSION A(1),B(N1C,1),C(N1C,1),D(N2C,1),BX(N1C,1),
  452.      1 SCRATC(LD2),IP(LD2),IX(LD2)
  453.       IF (N2C.EQ.0) RETURN
  454. C**
  455. C     D     WRITE(*,*) '  FACGF: START N1C=',N1C,' N2C=',N2C,' NBBL=',NBBL,
  456. C     D    1 ' ICASE=',ICASE,' ICASX=',ICASX
  457. C**
  458.       IBFL=14
  459.       IF (ICASX.LT.3) GO TO 1
  460. C     CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16
  461. C**
  462. C     D     WRITE(*,*) '  FACGF: CALL REBLK'
  463. C**
  464.       CALL REBLK (B,C,N1C,NPBX,N2C)
  465. C**
  466. C     D     WRITE(*,*) '  FACGF: RTRN REBLK'
  467. C**
  468.       IBFL=16
  469. 1     NPB=NPBL
  470.       IF (ICASX.EQ.2) REWIND 14
  471. C     COMPUTE INV(A)B AND WRITE ON TAPE14
  472.       DO 2 IB=1,NBBL
  473.       IF (IB.EQ.NBBL) NPB=NLBL
  474.       IF (ICASX.GT.1) READ (IBFL) ((BX(I,J),I=1,N1C),J=1,NPB)
  475. C**
  476. C     D     WRITE(*,*) '  FACGF: CALL SOLVES'
  477. C**
  478.       CALL SOLVES(A,BX,SCRATC,N1C,NP,N1,MP,M1,IP,NPB,13,13,LD2,
  479.      1 IRESRV)
  480. C**
  481. C     D     WRITE(*,*) '  FACGF: RTRN SOLVES N1C=',N1C,' N2C=',N2C,
  482. C     D    1' NBBL=',NBBL
  483. C**
  484.       IF (ICASX.EQ.2) REWIND 14
  485.       IF (ICASX.GT.1) WRITE (14) ((BX(I,J),I=1,N1C),J=1,NPB)
  486. 2     CONTINUE
  487.       IF (ICASX.EQ.1) GO TO 3
  488.       REWIND 11
  489.       REWIND 12
  490.       REWIND 15
  491.       REWIND IBFL
  492. 3     NPC=NPBL
  493. C     COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11
  494.       DO 8 IC=1,NBBL
  495.       IF (IC.EQ.NBBL) NPC=NLBL
  496.       IF (ICASX.EQ.1) GO TO 4
  497.       READ (15) ((C(I,J),I=1,N1C),J=1,NPC)
  498.       READ (12) ((D(I,J),I=1,N2C),J=1,NPC)
  499.       REWIND 14
  500. 4     NPB=NPBL
  501.       NIC=0
  502.       DO 7 IB=1,NBBL
  503.       IF (IB.EQ.NBBL) NPB=NLBL
  504.       IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB)
  505.       DO 6 I=1,NPB
  506.       II=I+NIC
  507.       DO 6 J=1,NPC
  508.       SUM= CMPLX(0.,0.)
  509.       DO 5 K=1,N1C
  510. 5     SUM=SUM+B(K,I)*C(K,J)
  511. 6     D(II,J)=D(II,J)-SUM
  512. 7     NIC=NIC+NPBL
  513.       IF (ICASX.GT.1) WRITE (11) ((D(I,J),I=1,N2C),J=1,NPBL)
  514. 8     CONTINUE
  515.       IF (ICASX.EQ.1) GO TO 9
  516.       REWIND 11
  517.       REWIND 12
  518.       REWIND 14
  519.       REWIND 15
  520. 9     N1CP=N1C+1
  521. C     FACTOR D-C(INV(A)B)
  522.       IF (ICASX.GT.1) GO TO 10
  523. C**
  524. C     D     WRITE(*,*) '  FACGF: CALL FACTR'
  525. C**
  526.       CALL FACTR(D,SCRATC,N2C,N2C,IP(N1CP),LD2)
  527. C**
  528. C     D     WRITE(*,*) '  FACGF: RTRN FACTR N1C=',N1C,' N2C=',N2C,
  529. C     D    1' NBBL=',NBBL
  530. C**
  531.       GO TO 13
  532. 10    IF (ICASX.EQ.4) GO TO 12
  533.       NPB=NPBL
  534.       IC=0
  535. C**
  536.       DO 11 IB=1,NBBL
  537.       IF (IB.EQ.NBBL) NPB=NLBL
  538.       II=IC+1
  539.       IC=IC+N2C*NPB
  540. C**
  541. C     D       WRITE(*,*) ' II=',II,' IB=',IB,' IC=',IC,' NPB=',NPB
  542. C     D       WRITE(*,*) ' (B(I,1),I=II,IC)=',(B(I,1),I=II,IC)
  543. C**
  544. 11    READ (11) (B(I,1),I=II,IC)
  545.       REWIND 11
  546. C**
  547. C     D     WRITE(*,*) '  FACGF: CALL FACTR AFTER 11'
  548. C**
  549.       CALL FACTR(B,SCRATC,N2C,N2C,IP(N1CP),LD2)
  550. C**
  551. C     D     WRITE(*,*) '  FACGF: RTRN FACTR AFTER 11'
  552. C**
  553.       NIC=N2C*N2C
  554.       WRITE (11) (B(I,1),I=1,NIC)
  555.       REWIND 11
  556.       GO TO 13
  557. C**
  558. 12    NBLSYS=NBLSYM
  559.       NPSYS=NPSYM
  560.       NLSYS=NLSYM
  561.       ICASS=ICASE
  562.       NBLSYM=NBBL
  563.       NPSYM=NPBL
  564.       NLSYM=NLBL
  565.       ICASE=3
  566.       IDM2=1
  567. C**
  568. C     D     WRITE(*,*) '  FACGF: CALL FACIO'
  569. C**
  570.       CALL FACIO (B,SCRATC,N2C,IDM2,IX(N1CP),11,12,16,11,LD2)
  571. C**
  572. C     D     WRITE(*,*) '  FACGF: RTRN FACIO'
  573. C     D     WRITE(*,*) '  FACGF: CALL LUNSCR'
  574. C**
  575.       CALL LUNSCR (B,N2C,IDM2,IP(N1CP),IX(N1CP),12,11,16)
  576. C**
  577. C     D     WRITE(*,*) '  FACGF: RTRN LUNSCR'
  578. C**
  579.       NBLSYM=NBLSYS
  580.       NPSYM=NPSYS
  581.       NLSYM=NLSYS
  582.       ICASE=ICASS
  583. 13     CONTINUE
  584. C**
  585. C     D     WRITE(*,*) '  FACGF: RETURN AT END ICASE=',ICASE
  586. C**
  587.       RETURN
  588.       END
  589.